home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
akcl1615.lha
/
lsp
/
ucall.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1989-05-05
|
4KB
|
144 lines
(in-package 'compiler)
(import 'si::switch)
(import 'sloop::sloop)
(provide "UCALL")
;;ucall is like funcall, except it assumes
;;1) its first arg has an inline-always property.
;;2) the order of evaluation of the remaining args is unimportant.
;;This can be useful when we know that the side effects caused by evaluating
;;the args do not affect the order of evaluation.
;;It also returns an indeterminate value.
(defun c1ucall (args &aux funob (info (compiler::make-info)))
(setq funob (compiler::c1funob (car args)))
(compiler::add-info info (cadr funob))
(list 'ucall info funob (compiler::c1args (cdr args) info))
)
(defun c2ucall (funob args &aux (*inline-blocks* 0)(*vs* *vs*))
(let* ((fname (caddr funob))
(props (car (get fname 'inline-always)))
new-args
)
(or props (error "no inline-always prop"))
(do ((v args (cdr v))
(types (car props) (cdr types)))
((null v) (setq new-args (nreverse new-args)))
(setq new-args
(append (inline-args (list (car v)) (list (car types)))
new-args)))
(wt-nl)
(wt-inline-loc (nth 4 props) new-args)
(wt ";")
(unwind-exit "Cnil")
(close-inline-blocks)
))
;;Usage (comment "hi there") ; will insert a comment at that point in
;;the program.
(defun c1comment (args)
(list 'comment (make-info) args))
(defun c2comment (args)
(let ((string (car args)))
(if (find #\/ string) (setq string (remove #\/ string)))
(wt "/* "string " */")))
(defmacro comment (a) a nil)
;;Usage: (tlet (char *) jack ....)
;;--> {char * V1; ...V1..
(defun c1tlet (args &aux (info (make-info)) (*vars* *vars*))
(let ((sym (cadr args))
(type (car args))
form )
(let ((var (c1make-var sym nil nil nil)))
(cond ((subtypep type 'fixnum)
(setf (var-type var) 'fixnum)))
(push var *vars*)
(setq form (c1expr* (cons 'progn (cddr args)) info))
(list 'tlet (second form) type var form))))
(defun c2tlet (type var orig &aux (stype type))
(setf (var-loc var) (next-cvar))
(or (stringp type) (setq stype (format nil "~(~a~)" type)))
(setf (var-kind var)
(cond ((subtypep type 'fixnum)
(setf (var-type var) 'fixnum))
(t 'object)))
(if (listp type) (setq stype (string-trim "()" stype)))
(wt-nl "{" stype " V" (var-loc var) ";" )
(c2expr orig)
(wt "}"))
(si::putprop 'tlet 'c1tlet 'c1special)
(si::putprop 'tlet 'c2tlet 'c2)
(defun c1clet (args)
(let ((string (car args))
(form (c1expr (cons 'progn (cdr args)))))
(list 'clet (second form) string form)))
(defun c2clet (string orig )
(wt-nl "{" string)
(c2expr orig)
(wt "}"))
;;Usage: Takes a STRING and BODY. Acts like progn
;;on the body, but the c code will have {string . c code for body}
;;Sample (clet "int jack; char *jane;" ....)
(defmacro clet (string &rest body) string `(progn ,@ body))
(si::putprop 'clet 'c1clet 'c1special)
(si::putprop 'clet 'c2clet 'c2)
(si::putprop 'comment 'c1comment 'c1special)
(si::putprop 'comment 'c2comment 'c2)
(si::putprop 'ucall 'c1ucall 'c1)
(si::putprop 'ucall 'c2ucall 'c2)
(defmacro def-inline (name args return-type &rest bod)
(let* ((side-effect-p (if (member (car bod)
'(:side-effect nil t))
(prog1 (and (car bod) t) (setq bod (cdr bod)))
nil))
(inline (list args return-type side-effect-p nil (car bod))))
`(car (push ',inline
(get ',name 'inline-always)))))
(defmacro defun-inline (name args return-type &rest bod)
(let* ((sym (gensym))
(named-args
(nthcdr (- 10 (length args)) '(X9 X8 X7 X6 X5 X4 X3 X2 X1 X0)))
(inline (eval `(def-inline ,sym ,args ,return-type ,@ bod))))
`(progn
(defun ,name ,named-args
(declare ,@ (sloop for v in named-args for w in args
when (not (eq t v))
collect (list w v)))
(the ,return-type (,sym ,@ named-args)))
(push ',inline
(get ',name 'inline-always)))))
(defmacro def-ucall (fun args string)
(let ((sym (gensym)))
`(progn
(def-inline ,sym ,args t t ,string)
(defmacro ,fun (&rest args) `(ucall ',',sym ,@ args)))))